home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / makcrc.scm < prev    next >
Text File  |  1999-04-19  |  3KB  |  88 lines
  1. ;;;; "makcrc.scm" Compute Cyclic Checksums
  2. ;;; Copyright (C) 1995, 1996, 1997 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'logical)
  21.  
  22. ;;;(define crc (eval (make-port-crc 16 #o010013)))
  23. ;;;(define crc (eval (make-port-crc 08 #o053)))
  24. ;;;(define (file-check-sum file) (call-with-input-file file crc32))
  25.  
  26. (define (make-port-crc . margs)
  27.   (define (make-mask hibit)
  28.     (+ (ash (+ -1 (ash 1 (+ 1 (- hibit 2)))) 1) 1))
  29.   (define accum-bits 32)
  30.   (define chunk-bits (integer-length (+ -1 char-code-limit)))
  31.   (define generator #f)
  32.   (cond ((pair? margs)
  33.      (set! accum-bits (car margs))
  34.      (cond ((pair? (cdr margs))
  35.         (set! generator (cadr margs))))))
  36.   (cond ((not generator)
  37.      (case accum-bits
  38.        ((32) (set! generator #b00000100110000010001110110110111))
  39.        (else (slib:error 'make-port-crc "no default polynomial for"
  40.                  accum-bits "bits")))))
  41.   (let* ((chunk-mask (make-mask chunk-bits))
  42.      (crctab (make-vector (+ 1 chunk-mask))))
  43.     (define (accum src)
  44.       `(set!
  45.     crc
  46.     (logxor (ash (logand ,(make-mask (- accum-bits chunk-bits)) crc)
  47.              ,chunk-bits)
  48.         (vector-ref crctab
  49.                 (logand ,chunk-mask
  50.                     (logxor
  51.                      (ash crc ,(- chunk-bits accum-bits))
  52.                      ,src))))))
  53.     (define (make-crc-table)
  54.       (letrec ((r (make-vector chunk-bits))
  55.            (remd (lambda (m)
  56.                (define rem 0)
  57.                (do ((i 0 (+ 1 i)))
  58.                ((>= i chunk-bits) rem)
  59.              (if (logbit? i m)
  60.                  (set! rem (logxor rem (vector-ref r i))))))))
  61.     (vector-set! r 0 generator)
  62.     (do ((i 1 (+ 1 i)))
  63.         ((>= i chunk-bits))
  64.       (let ((r-1 (vector-ref r (+ -1 i)))
  65.         (m-1 (make-mask (+ -1 accum-bits))))
  66.         (vector-set! r i (if (logbit? (+ -1 accum-bits) r-1)
  67.                  (logxor (ash (logand m-1 r-1) 1) generator)
  68.                  (ash (logand m-1 r-1) 1)))))
  69.     (do ((i 0 (+ 1 i)))
  70.         ((> i chunk-mask))
  71.       (vector-set! crctab i (remd i)))))
  72.     (cond ((>= (integer-length generator) accum-bits)
  73.        (slib:error 'make-port-crc
  74.                "generator longer than" accum-bits "bits")))
  75.     (make-crc-table)
  76.     `(lambda (port)
  77.        (define crc 0)
  78.        (define byte-count 0)
  79.        (define crctab ',crctab)
  80.        (do ((ci (read-char port) (read-char port)))
  81.        ((eof-object? ci))
  82.      ,(accum '(char->integer ci))
  83.      (set! byte-count (+ 1 byte-count)))
  84.        (do ((byte-count byte-count (ash byte-count ,(- chunk-bits))))
  85.        ((zero? byte-count))
  86.      ,(accum 'byte-count))
  87.        (logxor ,(make-mask accum-bits) crc))))
  88.